Deciphering VC
June-16-13
10:33 AM
VCLaw[Cobordism[top_Smoothing,mid_Smoothing], Cobordism[mid_Smoothing,bot_Smoothing]] := VCLaw[Cobordism[top, mid], Cobordism[mid, bot]] = Module[
  {decors, law1, law2, dots, dots1, dots2, dr1, dr2, dr, to, h, g2},
  {law1, law2} = {{}, {}};
  decors = Times @@ Cases[{mid},
    Loop[m_] :> (AppendTo[law1, bdot[m] -> mdot[m]]; AppendTo[law2, tdot[m] -> mdot[m]]; mdot[m]),
    Infinity  ];
  dots = Union[Last /@ DotRule[top, bot]];
  dots1 = Union[Last /@ (dr1 = DotRule[top, mid] /. bdot -> mdot)];
  dots2 = Union[Last /@ (dr2 = DotRule[mid, bot] /. tdot -> mdot)];
  dr = Flatten[Cases[EquivalenceClasses[Join[List @@@ dr1, List @@@ dr2]],
    l_List :> ((# -> First[l])& /@ Rest[l])  ]];
  decors *= Times @@ (Union[Last /@ dr] /. bdot -> h)^2;
  decors *= Times @@ (Cases[mid, P[__][m_] :> mdot[m], Infinity] /. dr /. bdot -> h);
  decors /= Times @@ (Join[dots1, dots2, dots] /. dr /. bdot -> h);
  decors = decors /. h[m_]^g2_ :> (2bdot[m])^(g2/2);
  decors *= Expand[Times @@ MapThread[If[#1===#2, 1, #1+#2]&,
    {dots, dots /. dr}  ]];
  law1 = Join[law1,
    DeleteCases[
Thread[to[dots1, dots1 /. dr]] /. mdot -> bdot,
to[m_, m_]
] /. to -> Rule];
  law2 = Join[law2,
    DeleteCases[
        Thread[to[dots2, dots2 /. dr]],
        to[m_, m_]
      ] /. to -> Rule    ];
  {law1, law2, decors}
];
VC[a_, b_, c__] := VC[a, VC[b,c]];
VC[Cobordism[top_Smoothing,mid_Smoothing, ds1_], Cobordism[mid_Smoothing,bot_Smoothing, ds2_]] := Module[
      {law1, law2, decor},
      {law1, law2, decor} = VCLaw[Cobordism[top, mid], Cobordism[mid, bot]];
      Cobordism[top, bot,
          Expand[decor*(ds1 /. law1)*(ds2 /. law2)] /. (_mdot)^2 -> 1 /. (_mdot -> 0)]
];